home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / tjgold.zip / INSTALL.001 / GOLDDATE.PAS < prev    next >
Pascal/Delphi Source File  |  1995-07-12  |  26KB  |  961 lines
  1. {--------------------------------------------------------------------------}
  2. {                Product: TechnoJock's Turbo Toolkit                       }
  3. {                Version: GOLD                                             }
  4. {                Build:   1.01                                             }
  5. {                                                                          }
  6. {                Copyright 1986-1995  TechnoJock Software, Inc.            }
  7. {                           All Rights Reserved                            }
  8. {                          Restricted by License                           }
  9. {--------------------------------------------------------------------------}
  10.  
  11.                     {**********************************}
  12.                     {**       Unit:   GOLDDATE       **}
  13.                     {**********************************}
  14.  
  15. {++++++++++++++++++++++++++++++} unit GOLDDATE; {++++++++++++++++++++++++++++}
  16.  
  17. {$I GOLDFLAG.INC}
  18. {$IFNDEF GOLDDATE}
  19.    {$DEFINE GOLDDATE}
  20. {$ENDIF}
  21.  
  22. {++++++++++++++++++++++++++++++++} INTERFACE {+++++++++++++++++++++++++++++++}
  23.  
  24. uses CRT, DOS,
  25.      GoldStr, GoldFast, GoldHard, GoldWin;
  26.  
  27. const AM: string[10] = ' am';
  28.       PM: string[10] = ' pm';
  29.       CompleteDay = 86400; { number of seconds in 24 hours }
  30.  
  31. type
  32.    Dates = longint;
  33.    gDate = (MMDDYY,MMDDYYYY,MMYY,MMYYYY,DDMMYY,DDMMYYYY,YYMMDD,YYYYMMDD);
  34.    gTime = (HHMMSS,HHMM);
  35.    StrShort = string[20];
  36.    gMonths  = array[1..12] of StrShort;
  37.    gDays = array[0..6] of StrShort;
  38.    gHours = array[0..12] of StrShort;
  39.    gMinSec = array[0..59] of StrShort;
  40.  
  41.    DATESet = record
  42.       ECode: integer;
  43.       EMsgFunc: ErrMsgFunc;
  44.       LastYearNextCentury: byte;
  45.       dSeparator: char;
  46.       tSeparator: char;
  47.       ClockX: byte;
  48.       ClockY: byte;
  49.       ClockFB: byte;
  50.    end;
  51.  
  52. const
  53.    Days: gDays = ('Sunday','Monday','Tuesday','Wednesday',
  54.                   'Thursday','Friday','Saturday');
  55.    Months: gMonths = ('January','February','March','April',
  56.                       'May','June','July','August','September',
  57.                       'October','November','December');
  58.  
  59. function  LastDateError:integer;
  60. { Date methods }
  61. function  Date:string;
  62. function  GregtoJul(M,D,Y:longint):longint;
  63. procedure JultoGreg(Jul:longint; var M,D: word; var Y:longint);
  64. function  Day(DStr:string;Format:gDate):word;
  65. function  Month(DStr:string;Format:gDate):word;
  66. function  Year(DStr:string;Format:gDate):word;
  67. function  StrtoJul(DStr:string;Format:gDate):longint;
  68. function  DOWNum(DStr:string;Format:gDate):byte;
  69. function  DOWStr(DayByte:byte): string;
  70. function  DOWJul(Jul:longint):byte;
  71. function  GregtoStr(M,D,Y:longint;Format:gDate):string;
  72. function  JultoStr(Jul:longint;Format:gDate):string;
  73. function  TodayinJul:longint;
  74. function  ValidDate(M,D,Y:longint):boolean;
  75. function  ValidDateStr(DStr:string;Format:gDate):boolean;
  76. function  StripDateStr(DStr:string;Format:gDate):string;
  77. function  FancyDateStr(Jul:longint; Long,Day:boolean):string;
  78. function  RelativeDate(DStr:string;Format:gDate;Delta:longint):string;
  79. function  RelativeDateYMD(DStr:string;Format:gDate;Y,M,D:longint):string;
  80. function  StartOfYear(Jul:longint):longint;
  81. function  EndOfYear(Jul:longint):longint;
  82. function  DateFormat(Format:gDate):string;
  83. function  UnformattedDate(InDate:string):string;
  84. { Time methods }
  85. function  Time:string;
  86. procedure Clock;
  87. function  Hour(TStr:string;Format:gTime):word;
  88. function  Minute(TStr:string;Format:gTime):word;
  89. function  Second(TStr:string;Format:gTime):word;
  90. function  TimeStrToLong(TStr:string;Format:gTime):longint;
  91. function  LongToTimeStr(Secs:longint;Format:gTime;AmPm,Mltry:boolean):string;
  92. function  NowInLong:longint;
  93. function  ValidTime(Hr,Mn,Sc:longint;Format:gTime;Mltry:boolean):boolean;
  94. function  ValidTimeStr(TStr:string;Format:gTime;Mltry:boolean):boolean;
  95. function  StripTimeStr(TStr:string;Format:gTime):string;
  96. function  TimeToLong(H,M,S:word):longint;
  97. function  TimeFormat(Format:gTime):string;
  98. function  TimeDiff(StartTime, StopTime: longint): longint;
  99.  
  100. {$IFDEF TTT5}
  101.  
  102. function  DMY_to_String(D,M,Y:word;format:byte): string;
  103. function  Date_To_Julian(InDate:string;format:byte): longint;
  104. function  Julian_to_Date(J:longint;format:byte):string;
  105. function  Today_in_Julian: longint;
  106. function  Date_Within_Range(Min,Max,Test:longint):boolean;
  107. function  Valid_Date(Indate:string;format:byte): boolean;
  108. function  Future_Date(InDate:string;format:byte;Days:word): string;
  109. function  Unformatted_date(InDate:string): string;
  110.  
  111. {$ENDIF}
  112.  
  113. var
  114.    DateVars: DATESet;
  115.  
  116. {+++++++++++++++++++++++++++++} IMPLEMENTATION {+++++++++++++++++++++++++++++}
  117.  
  118. {$IFOPT F-}
  119.    {$DEFINE FOFF}
  120.    {$F+}
  121. {$ENDIF}
  122. function DateEMsg(ECode:integer): string;
  123. {}
  124. begin
  125.    case Ecode of
  126.       0: exit;
  127.       1001: DateEMsg := 'DOW number is out-of-range';
  128.       1002: DateEMsg := 'Invalid date format';
  129.       1003: DateEMsg := 'Invalid time format';
  130.       else
  131.          DateEMsg := 'Internal date error';
  132.    end; {case}
  133. end; { DateEMsg }
  134. {$IFDEF FOFF}
  135.    {$F-}
  136.    {$UNDEF FOFF}
  137. {$ENDIF}
  138.  
  139. procedure DateSetError(ECode:integer);
  140. {}
  141. {$IFOPT D+}
  142. var Ch: char;
  143.     Msg: string;
  144. {$ENDIF}
  145. begin
  146.    DateVars.Ecode := ECode;
  147. {$IFOPT D+}  {if debug active display an error message and terminate}
  148.    if Ecode <> 0 then
  149.    begin
  150.       str(Ecode,Msg);
  151.       Msg := Msg+': '+DateVars.EMsgFunc(Ecode);
  152.       SetWinIgnore(true);
  153.       if PromptCustom(' GoldDate Error ',Msg,' ~I~gnore ',' ~A~bort ','',279,286,0,0, 10000) = 2 then
  154.          Halt;
  155.    end;
  156. {$ENDIF}
  157. end; { DateSetError }
  158.  
  159. function LastDateError: integer;
  160. {}
  161. begin
  162.    LastDateError := DateVars.ECode;
  163. end; { LastDateError }
  164.  
  165.                           {*********************}
  166.                           {**  Date Routines  **}
  167.                           {*********************}
  168.  
  169. function Date: String;
  170. {}
  171. var
  172.     Y, M, D,
  173.     DayOfWeek: word;
  174.     Year   : string;
  175.     Day    : string;
  176. begin
  177.    GetDate(Y,M,D,DayofWeek);
  178.    Str(Y,Year);
  179.    Str(D,Day);
  180.    Date := Days[DayOfWeek]+' '+Months[M]+' '+Day+', '+Year;
  181. end;
  182.  
  183. function PadDateStr(DStr:string;Format:gDate):string;
  184. {}
  185. var
  186.    Part1,Part2,Part3: string;
  187.    L,P: byte;
  188.    Sep1,Sep2:char;
  189.  
  190.    procedure PadOut(var S:string; width:byte);
  191.    begin
  192.       S := padright(S,width,'0');
  193.    end; { PadOut }
  194.  
  195. begin
  196.    if length(DStr) = length(DateFormat(Format)) then
  197.    begin
  198.       PadDateStr := DStr;
  199.       exit;
  200.    end;
  201.    P := 0;
  202.    L := length(DStr);
  203.    repeat
  204.       inc(P);
  205.    until (not (DStr[P] in ['0'..'9'])) or (P > L);
  206.    if P > L then
  207.    begin
  208.       PadDateStr := DStr;
  209.       exit;
  210.    end;
  211.    Part1 := copy(DStr,1,pred(P));
  212.    Sep1 := DStr[P];
  213.    delete(DStr,1,P);
  214.    P:= 0;
  215.    repeat
  216.       inc(P);
  217.    until (not (DStr[P] in ['0'..'9'])) or (P > L);
  218.    Part2 := copy(DStr,1,pred(P));
  219.    Sep2 := DStr[P];
  220.    Part3 := copy(DStr,succ(P),4);
  221.    case Format of
  222.       MMDDYY,YYMMDD,DDMMYY:begin
  223.           PadOut(Part1,2);
  224.           PadOut(Part2,2);
  225.           PadOut(Part3,2);
  226.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  227.       end;
  228.       MMDDYYYY,DDMMYYYY:begin
  229.           PadOut(Part1,2);
  230.           PadOut(Part2,2);
  231.           PadOut(Part3,4);
  232.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  233.       end;
  234.       YYYYMMDD:begin
  235.           PadOut(Part1,4);
  236.           PadOut(Part2,2);
  237.           PadOut(Part3,2);
  238.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  239.       end;
  240.       MMYY:begin
  241.           PadOut(Part1,2);
  242.           PadOut(Part2,2);
  243.           DStr := Part1+Sep1+Part2;
  244.       end;
  245.       MMYYYY:begin
  246.           PadOut(Part1,2);
  247.           PadOut(Part2,4);
  248.           DStr := Part1+Sep1+Part2;
  249.       end;
  250.    end; {case}
  251.    PadDateStr := DStr;
  252. end; { PadDateStr }
  253.  
  254. function GregtoJul(M,D,Y:longint):longint;
  255. {}
  256. var Factor: integer;
  257. begin
  258.    if M < 3 then
  259.       Factor := -1
  260.    else
  261.       Factor := 0;
  262.    GregtoJul :=  (1461*(Factor+4800+Y) div 4)
  263.                + ((M-2-(Factor*12))*367) div 12
  264.                - (3*((Y+4900+Factor) div 100) div 4)
  265.                + D
  266.                - 32075;
  267. end; { GregtoJul }
  268.  
  269. procedure JultoGreg(Jul:longint; var M,D: word; var Y:longint);
  270. {}
  271. var U,V,W,X: longint;
  272. begin
  273.    if Jul = 0 then
  274.    begin
  275.       M := 0;
  276.       D := 0;
  277.       Y := 0;
  278.    end else
  279.    begin
  280.       inc(Jul,68569);
  281.       W := (Jul*4) div 146097;
  282.       dec(Jul,((146097*W)+3) div 4);
  283.       X := 4000*succ(Jul) div 1461001;
  284.       dec(Jul,((1461*X) div 4) - 31);
  285.       V := 80*Jul div 2447;
  286.       U := V div 11;
  287.       D := Jul - (2447*V div 80);
  288.       M := V + 2 - (U*12);
  289.       Y := X + U + (W-49)*100;
  290.    end;
  291. end; { JultoGreg }
  292.  
  293. function Day(DStr:string;Format:gDate): word;
  294. {}
  295. var
  296.    DayStr: string;
  297. begin
  298.    DStr := PadDateStr(DStr,Format);
  299.    case Format of
  300.       MMDDYY,
  301.       MMDDYYYY: DayStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  302.       DDMMYY,
  303.       DDMMYYYY: DayStr := NthNumber(DStr,1)+NthNumber(DStr,2);
  304.       YYMMDD:   DayStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  305.       YYYYMMDD: DayStr := NthNumber(DStr,7)+NthNumber(DStr,8);
  306.       else     DayStr := '01';
  307.    end; {case}
  308.    Day := StrToInt(DayStr);
  309. end; { Day }
  310.  
  311. function Month(DStr:string;Format:gDate): word;
  312. {}
  313. var
  314.    MonStr: string;
  315. begin
  316.    DStr := PadDateStr(DStr,Format);
  317.    case Format of
  318.       MMDDYY,
  319.       MMDDYYYY,
  320.       MMYY,
  321.       MMYYYY  :  MonStr := NthNumber(DStr,1)+NthNumber(DStr,2);
  322.       YYMMDD,
  323.       DDMMYY,
  324.       DDMMYYYY:  MonStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  325.       YYYYMMDD:  MonStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  326.    end; {case}
  327.    Month := StrToInt(MonStr);
  328. end; { Month }
  329.  
  330. function Year(DStr:string;Format:gDate): word;
  331. {}
  332. var YrStr: string;
  333.     TmpYr: word;
  334. begin
  335.    DStr := PadDateStr(DStr,Format);
  336.    Case Format of
  337.       MMDDYY,
  338.       DDMMYY   : YrStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  339.       MMDDYYYY,
  340.       DDMMYYYY : YrStr := NthNumber(DStr,5)+NthNumber(DStr,6)
  341.                           + NthNumber(DStr,7)+NthNumber(DStr,8);
  342.       MMYY     : YrStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  343.       MMYYYY   : YrStr := NthNumber(DStr,3)+NthNumber(DStr,4)
  344.                           + NthNumber(DStr,5)+NthNumber(DStr,6);
  345.       YYMMDD   : YrStr := NthNumber(DStr,1)+NthNumber(DStr,2);
  346.       YYYYMMDD : YrStr := NthNumber(DStr,1)+NthNumber(DStr,2)
  347.                           + NthNumber(DStr,3)+NthNumber(DStr,4);
  348.    end;
  349.    TmpYr := StrToInt(YrStr);
  350.    if (TmpYr >= 0) and (TmpYr <= 99) and (length(YrStr) <= 2) then
  351.    begin
  352.       if TmpYr < DateVars.LastYearNextCentury then
  353.          TmpYr := 2000 + TmpYr
  354.       else
  355.          TmpYr := 1900 + TmpYr;
  356.    end;
  357.    Year := TmpYr;
  358. end; { Year }
  359.  
  360. function GregtoStr(M,D,Y:longint;Format:gDate): string;
  361. {}
  362. var
  363.    PadChar : char;
  364.    DD,MM: string[2];
  365.    YY: string[4];
  366.    TempStr: string[15];
  367. begin
  368.    PadChar := DateVars.dSeparator;
  369.    DD := InttoStr(D);
  370.    if D < 10 then
  371.       DD := '0'+DD;
  372.    MM := InttoStr(M);
  373.    if M < 10 then
  374.       MM := '0'+MM;
  375.    if (Format in [MMDDYY,MMYY,DDMMYY,YYMMDD])
  376.    and ((Y > 99) or (Y < -99)) then
  377.       Y := Y Mod 100;
  378.    YY := InttoStr(abs(Y));
  379.    if (Y < 10) and (Y > -1) then
  380.       YY := '0'+YY;
  381.    Case Format of
  382.       MMDDYY,
  383.       MMDDYYYY: TempStr := MM+PadChar+DD+Padchar+YY;
  384.       MMYY,
  385.       MMYYYY  : TempStr := MM+Padchar+YY;
  386.       DDMMYY,
  387.       DDMMYYYY: TempStr := DD+PadChar+MM+Padchar+YY;
  388.       YYMMDD,
  389.       YYYYMMDD: TempStr := YY+PadChar+MM+Padchar+DD;
  390.    end; {case}
  391.    if Y < 0 then
  392.       GregToStr := '-'+TempStr
  393.    else
  394.       GregToStr := TempStr;
  395. end; { GregtoStr }
  396.  
  397. function JultoStr(Jul:longint;Format:gDate): string;
  398. {}
  399. var
  400.    M,D:word;
  401.    Y: longint;
  402. begin
  403.    JultoGreg(Jul,M,D,Y);
  404.    JultoStr := GregtoStr(M,D,Y,Format);
  405. end; { JultoStr }
  406.  
  407. function TodayinJul: longint;
  408. {}
  409. var M,D,Y,DOW: word;
  410. begin
  411.    GetDate(Y,M,D,DOW);
  412.    TodayinJul := GregtoJul(M,D,Y);
  413. end; { TodayinJul }
  414.  
  415. function LeapYear(Y:longint):boolean;
  416. {}
  417. begin
  418.    LeapYear := (Y mod 4 = 0) and ((Y mod 400 = 0) or (Y mod 100 <> 0));
  419. end; { LeapYear }
  420.  
  421. function ValidDate(M,D,Y:longint):boolean;
  422. {}
  423. begin
  424.    if (D < 1)
  425.    or (D > 31)
  426.    or (M < 1)
  427.    or (M > 12)
  428.    then
  429.       ValidDate := False
  430.    else
  431.       Case M of
  432.          4,6,9,11: ValidDate := (D <= 30);
  433.          2:        ValidDate := (D <= 28)
  434.                                 or ( (D = 29) and LeapYear(Y));
  435.           else ValidDate := true;
  436.       end; {case}
  437. end; { ValidDate }
  438.  
  439. function  ValidDateStr(DStr:string;Format:gDate): boolean;
  440. {}
  441. var
  442.   M,D,Y: word;
  443.   ECount:integer;
  444. begin
  445.    ECount := 0;
  446.    StrVars.Ecode := 0;
  447.    StrVars.SuppressErrors := true;
  448.    M := Month(DStr,Format);
  449.    inc(ECount,LastStrError);
  450.    D := Day(DStr,Format);
  451.    inc(ECount,LastStrError);
  452.    Y := Year(DStr,Format);
  453.    inc(ECount,LastStrError);
  454.    if ECount > 0 then
  455.       ValidDateStr := false
  456.    else
  457.       ValidDateStr := ValidDate(M,D,Y);
  458.    StrVars.SuppressErrors := false;
  459. end; { ValidDateStr }
  460.  
  461. function DOWJul(Jul:longint): byte;
  462. var
  463.    M,D: word;
  464.    Y: longint;
  465.    N: longint;
  466. begin
  467.    JultoGreg(Jul,M,D,Y);
  468.    if M <= 2 then
  469.      N := 1461 * (longint(Y)-1) div 4 + 153 * (longint(M)+13) div 5 + longint(D)
  470.    else
  471.      N := 1461 * longint(Y) div 4 + 153 * (longint(M)+1) div 5 + longint(D);
  472.    N:= abs((N - 621049)) mod 7;
  473.    DOWJul := N;
  474. end; { DOWJul }
  475.  
  476. function StrtoJul(DStr:string;Format:gDate):longint;
  477. {}
  478. var
  479.   M,D,Y:longint;
  480. begin
  481.    M := Month(Dstr,Format);
  482.    D := Day(Dstr,Format);
  483.    Y := Year(Dstr,Format);
  484.    StrtoJul := GregtoJul(M,D,Y);
  485. end; { StrtoJul }
  486.  
  487. function DOWNum(DStr:string;Format:gDate): byte;
  488. {returns 0 thru 6}
  489. begin
  490.    DOWNum := DOWJul(StrtoJul(Dstr,Format));
  491. end; { DOWNum }
  492.  
  493. function DOWStr(DayByte:byte): string;
  494. {0=Sunday ... 6=Saturday}
  495. begin
  496.    if (DayByte in [0..6]) then
  497.       DOWStr := Days[DayByte]
  498.    else
  499.       DateSetError(1001);
  500. end; { DOWStr }
  501.  
  502. function StripDateStr(DStr:string;Format:gDate):string;
  503. {}
  504. begin
  505.    case Format of
  506.       MMDDYY,
  507.       MMDDYYYY,
  508.       DDMMYY,
  509.       DDMMYYYY,
  510.       YYMMDD: begin
  511.                  delete(Dstr,3,1);
  512.                  delete(Dstr,5,1);
  513.               end;
  514.       MMYY,
  515.       MMYYYY  : delete(DStr,3,1);
  516.       YYYYMMDD: begin
  517.                   delete(DStr,5,1);
  518.                   delete(DStr,7,1);
  519.                 end;
  520.    end; {case}
  521.    StripDateStr := DStr;
  522. end; { StripDateStr }
  523.  
  524. function FancyDateStr(Jul:longint; Long,Day:boolean): string;
  525. {}
  526. var
  527.   M,D:word;
  528.   Y: longint;
  529.   TheDay: byte;
  530.   Str: string;
  531. begin
  532.    JultoGreg(Jul,M,D,Y);
  533.    Str := ' '+InttoStr(D)+', '+IntToStr(Y);
  534.    if Long then
  535.       Str := Months[M] + Str
  536.    else
  537.       Str := copy(Months[M],1,3) + Str;
  538.    if Day then
  539.    begin
  540.       TheDay := DOWJul(Jul);
  541.       if Long then
  542.          Str := Days[TheDay] + ' ' + Str
  543.       else
  544.          Str := copy(Days[TheDay],1,3) + ' ' + Str;
  545.    end;
  546.    FancyDateStr := Str;
  547. end; { FancyDateStr }
  548.  
  549. function RelativeDate(DStr:string;Format:gDate;Delta:longint):string;
  550. {Delta is number of days from DStr}
  551. begin
  552.    RelativeDate := JultoStr(StrtoJul(DStr,Format)+Delta,Format);
  553. end; { RelativeDate }
  554.  
  555. function  RelativeDateYMD(DStr:string;Format:gDate;Y,M,D:longint):string;
  556. {Y,M,D is number of Years, Months, and Days}
  557. var TmpM,TmpD: word;
  558.     TmpY, TmpBase: longint;
  559. begin
  560.    JulToGreg(StrToJul(DStr,Format),TmpM,TmpD,TmpY);
  561.    TmpY := TmpY + (Y + (M div 12));
  562.    inc(TmpM,M mod 12);
  563.    TmpBase := GregToJul(TmpM,TmpD,TmpY);
  564.    RelativeDateYMD := RelativeDate(JulToStr(TmpBase,Format),Format,D);
  565. end; { RelativeDateYMD }
  566.  
  567. function EndOfMonth(Jul:longint):longint;
  568. {}
  569. var
  570.    M,D:word;
  571.    Y: longint;
  572. begin
  573.    JultoGreg(Jul,M,D,Y);
  574.    case M of
  575.       4,6,9,11: D := 30;
  576.       2: if (Y mod 4 = 0) and (Y <> 0) and (Y <> 1900) then
  577.             D := 29
  578.          else
  579.             D := 28;
  580.       else D := 31;
  581.    end; {case}
  582.    EndOfMonth := GregtoJul(M,D,Y);
  583. end; { EndOfMonth }
  584.  
  585. function StartOfMonth(Jul:longint):longint;
  586. {}
  587. var
  588.    M,D:word;
  589.    Y: longint;
  590. begin
  591.    JultoGreg(Jul,M,D,Y);
  592.    StartOfMonth := GregtoJul(M,1,Y);
  593. end; { StartOfMonth }
  594.  
  595. function StartOfYear(Jul:longint):longint;
  596. {}
  597. var
  598.    M,D:word;
  599.    Y: longint;
  600. begin
  601.    JultoGreg(Jul,M,D,Y);
  602.    StartOfYear := GregtoJul(1,1,Y);
  603. end; { StartOfYear }
  604.  
  605. function EndOfYear(Jul:longint):longint;
  606. {}
  607. var
  608.    M,D:word;
  609.    Y: longint;
  610. begin
  611.    JultoGreg(Jul,M,D,Y);
  612.    EndOfYear := GregtoJul(12,31,Y);
  613. end; { EndOfYear }
  614.  
  615. function DateFormat(Format:gDate):string;
  616. {}
  617. begin
  618.    with DateVars do
  619.    begin
  620.       DateFormat := '';
  621.       case Format of
  622.          MMDDYY: DateFormat := 'MM'+dSeparator+'DD'+dSeparator+'YY';
  623.          MMDDYYYY: DateFormat := 'MM'+dSeparator+'DD'+dSeparator+'YYYY';
  624.          MMYY: DateFormat := 'MM'+dSeparator+'YY';
  625.          MMYYYY: DateFormat := 'MM'+dSeparator+'YYYY';
  626.          DDMMYY: DateFormat := 'DD'+dSeparator+'MM'+dSeparator+'YY';
  627.          DDMMYYYY: DateFormat := 'DD'+dSeparator+'MM'+dSeparator+'YYYY';
  628.          YYMMDD: DateFormat := 'YY'+dSeparator+'MM'+dSeparator+'DD';
  629.          YYYYMMDD: DateFormat :=  'YYYY'+dSeparator+'MM'+dSeparator+'DD';
  630.       else
  631.          DateSetError(1002); {Invalid date format}
  632.       end; {case}
  633.    end;
  634. end; { DateFormat }
  635.  
  636. function UnformattedDate(InDate:string): string;
  637. {strips all non numeric characters}
  638. var I: Integer;
  639.  
  640.    function Digit(C:char): boolean;
  641.    {}
  642.    begin
  643.        Digit := C in ['0'..'9'];
  644.    end; { Digit }
  645.  
  646. begin
  647.    I := 1;
  648.    repeat
  649.       if (digit(Indate[I]) = false) and (length(Indate) > 0) then
  650.          delete(Indate,I,1)
  651.       else
  652.          I := succ(I);
  653.    until (I > length(Indate)) or (Indate = '');
  654.    UnformattedDate := Indate;
  655. end; { Unformatteddate }
  656.  
  657.                           {*********************}
  658.                           {**  Time Routines  **}
  659.                           {*********************}
  660.  
  661. function time: string;
  662. {}
  663. var
  664.   hour,min,sec:     string[2];
  665.   tag: string[10];
  666.   H,M,S,T : word;
  667. begin
  668.    with DateVars do
  669.    begin
  670.       tag := AM;
  671.       GetTime(H,M,S,T);
  672.       Str(M,Min);
  673.       Str(S,Sec);
  674.       if S < 10 then            {pad a leading zero if sec is < 10}
  675.          sec := '0'+sec;
  676.       if M < 10 then            {pad a leading zero if min is < 10}
  677.          min := '0'+min;
  678.       if H > 12 then
  679.       begin
  680.          dec(H,12);
  681.          tag := PM;
  682.       end;
  683.       time := PadRight(IntToStr(H),2,' ')+tSeparator+min+tSeparator+sec+tag;
  684.    end;
  685. end; { Time }
  686.  
  687. procedure Clock;
  688. {writes current PC time to a predestined location}
  689. begin
  690.    with DateVars do
  691.    begin
  692.       WriteAT(ClockX,ClockY,ClockFB,Time);
  693.    end;
  694. end; { Clock }
  695.  
  696. function  Hour(TStr:string;Format:gTime): word;
  697. {}
  698. begin
  699.    with DateVars do
  700.    begin
  701.       Hour := StrToInt(copy(TStr,1,pred(pos(tSeparator,TStr))));
  702.    end;
  703. end; { Hour }
  704.  
  705. function  Minute(TStr:string;Format:gTime): word;
  706. {}
  707. var P:byte;
  708. begin
  709.    with DateVars do
  710.    begin
  711.       if Format = HHMMSS then
  712.       begin
  713.          P := pos(tSeparator,TStr);
  714.          Minute := StrToInt(copy(TStr,P,pred(LastPos(tSeparator,TStr)-P)));
  715.       end else
  716.          Minute := StrToInt(copy(TStr,succ(pos(tSeparator,TStr)),2));
  717.    end;
  718. end; { Minute }
  719.  
  720. function  Second(TStr:string;Format:gTime): word;
  721. {}
  722. begin
  723.    with DateVars do
  724.    begin
  725.       if Format = HHMMSS then
  726.          Second := StrToInt(copy(TStr,succ(LastPos(tSeparator,TStr)),2))
  727.       else Second := 0;
  728.    end;
  729. end; { Second }
  730.  
  731. function  TimeStrToLong(TStr:string;Format:gTime):longint;
  732. {}
  733. var Hr,Mn,Sc:longint;
  734. begin
  735.    with DateVars do
  736.    begin
  737.       Hr := Hour(TStr,Format);
  738.       Mn := Minute(TStr,Format);
  739.       Sc := Second(TStr,Format);
  740.       TimeStrToLong := (Hr*3600)+(Mn*60)+Sc;
  741.    end;
  742. end; { TimeStrToLong }
  743.  
  744. function  LongToTimeStr(Secs:longint;Format:gTime;AmPm,Mltry:boolean): string;
  745. {}
  746. var Hr,Mn,Sc: word;
  747.     HrStr,MnStr,ScStr,Tag: string[3];
  748. begin
  749.    with DateVars do
  750.    begin
  751.       Tag := '';
  752.       Hr := Secs div 3600;
  753.       if not Mltry then
  754.       begin
  755.          if Hr > 12 then
  756.          begin
  757.             Hr := Hr - 12;
  758.             If AmPm then
  759.                Tag := PM;
  760.          end else
  761.             if AmPm then
  762.                Tag := AM;
  763.       end;
  764.       HrStr := PadRight(IntToStr(Hr),2,'0');
  765.       Mn := (Secs mod 3600) div 60;
  766.       MnStr := PadRight(IntToStr(Mn),2,'0');
  767.       Sc := Secs mod 60;
  768.       ScStr := PadRight(IntToStr(Sc),2,'0');
  769.       case Format of
  770.          HHMMSS: LongToTimeStr := HrStr+tSeparator+MnStr+tSeparator+ScStr+Tag;
  771.          HHMM: LongToTimeStr := HrStr+tSeparator+MnStr+Tag;
  772.       end;
  773.    end;
  774. end; { LongToTimeStr }
  775.  
  776. function  NowInLong: longint;
  777. {}
  778. var Hr,Mn,Sc,Sc100: word;
  779. begin
  780.    gettime(Hr,Mn,Sc,Sc100);
  781.    NowInLong := ((longint(Hr) * 3600) + (Mn * 60)) + Sc;
  782. end; { NowInLong }
  783.  
  784. function  ValidTime(Hr,Mn,Sc:longint;Format:gTime;Mltry:boolean):boolean;
  785. {}
  786. begin
  787.    with DateVars do
  788.    begin
  789.       ValidTime := false;
  790.       if ((Mltry and (Hr < 24)) or (Hr < 13)) and (Hr >= 0)
  791.       and (Mn >= 0) and (Mn < 60)
  792.       and (Format = HHMM) or ((Sc >= 0) and (Sc < 60)) then
  793.                ValidTime := true;
  794.    end;
  795. end; { ValidTime }
  796.  
  797. function  ValidTimeStr(TStr:string;Format:gTime;Mltry:boolean): boolean;
  798. {a valid time string must include a 2 character Hour, Minute,
  799.  and Second. It must also contain 2 time separators in positions
  800.  3 and 6 with respect given to the appropriate Format}
  801. var Hr,Mn,Sc:word;
  802. begin
  803.    with DateVars do
  804.    begin
  805.       ValidTimeStr := false;
  806.       Hr := Hour(TStr,Format);
  807.       Mn := Minute(TStr,Format);
  808.       Sc := Second(TStr,Format);
  809.       if ((Format = HHMMSS) and (length(TStr) = 8)) or
  810.          ((Format = HHMM) and (length(TStr) = 5)) then
  811.          ValidTimeStr := ValidTime(Hr,Mn,Sc,Format,Mltry);
  812.    end;
  813. end; { ValidTimeStr }
  814.  
  815. function  StripTimeStr(TStr:string;Format:gTime):string;
  816. {}
  817. begin
  818.    with DateVars do
  819.    begin
  820.       TStr := Strip('A',tSeparator,TStr);
  821.    end;
  822. end; { StripTimeStr }
  823.  
  824. function TimeToLong(H,M,S:word): longint;
  825. {converts H M S to a longint value}
  826. begin
  827.    TimeToLong := (H*3600)+(M*60)+S;
  828. end; { TimeToLong }
  829.  
  830. function  TimeFormat(Format:gTime):string;
  831. {}
  832. begin
  833.    with DateVars do
  834.    begin
  835.       TimeFormat := '';
  836.       case Format of
  837.          HHMMSS: TimeFormat := 'HH'+tSeparator+'MM'+tSeparator+'SS';
  838.          HHMM: TimeFormat := 'HH'+tSeparator+'MM';
  839.       else
  840.          DateSetError(1003); {Invalid time format}
  841.       end;
  842.    end;
  843. end; { TimeFormat }
  844.  
  845. function  TimeDiff(StartTime, StopTime: longint): longint;
  846. {based on a 24 hour clock}
  847. begin
  848.    if ((StartTime >= 0) and (StartTime <= CompleteDay))
  849.       and ((StopTime >= 0) and (StopTime <= CompleteDay)) then
  850.    begin
  851.       if StartTime > StopTime then
  852.          TimeDiff := (CompleteDay - StartTime) + StopTime
  853.       else
  854.          TimeDiff := StopTime - StartTime;
  855.    end else
  856.       TimeDiff := 0;
  857. end; { TimeDiff }
  858.  
  859.               {**********************************************}
  860.               {**  U N I T   I N I T I A L I Z A T I O N   **}
  861.               {**********************************************}
  862.  
  863. procedure DateDefaultSettings;
  864. {}
  865. begin
  866.    with DateVars do
  867.    begin
  868.       LastYearNextCentury := 20;
  869.       dSeparator := '/';
  870.       tSeparator := ':';
  871.       ClockX := 67;
  872.       ClockY := 1;
  873.       ClockFB := $0F;  { white }
  874.    end;
  875. end; {DateDefaultSettings}
  876.  
  877. procedure GoldDATEInit;
  878. {}
  879. begin
  880.    DateDefaultSettings;
  881.    with DateVars do
  882.    begin
  883.       EMsgFunc := DateEMsg;
  884.       Ecode := 0;
  885.    end;
  886. end; {GoldDATEInit}
  887.  
  888. {$IFDEF TTT5}
  889.  
  890. function ConvertDateFormat(format:byte): gDate;
  891. {}
  892. var Dfmt: gDate;
  893. begin
  894.    case format of
  895.       1: Dfmt := MMDDYY;
  896.       2: Dfmt := MMDDYYYY;
  897.       3: Dfmt := MMYY;
  898.       4: Dfmt := MMYYYY;
  899.       5: Dfmt := DDMMYY;
  900.       6: Dfmt := DDMMYYYY;
  901.       7: Dfmt := YYMMDD;
  902.       8: Dfmt := YYYYMMDD;
  903.       else Dfmt := MMDDYY;
  904.    end;
  905.    ConvertDateFormat := Dfmt;
  906. end; { ConvertDateFormat }
  907.  
  908. function  DMY_to_String(D,M,Y:word;format:byte): string;
  909. {included for TTT5 compatibility}
  910. begin
  911.    DMY_to_String := GregToStr(M,D,Y,ConvertDateFormat(format));
  912. end; { DMY_to_String }
  913.  
  914. function  Date_To_Julian(InDate:string;format:byte): longint;
  915. {included for TTT5 compatibility}
  916. begin
  917.    Date_To_Julian := StrToJul(InDate,ConvertDateFormat(format));
  918. end; { Date_To_Julian }
  919.  
  920. function  Julian_to_Date(J:longint;format:byte):string;
  921. {included for TTT5 compatibility}
  922. begin
  923.    Julian_to_Date := JulToStr(J,ConvertDateFormat(format));
  924. end; { Julian_to_Date }
  925.  
  926. function  Today_in_Julian: longint;
  927. {included for TTT5 compatibility}
  928. begin
  929.    Today_in_Julian := TodayInJul;
  930. end; { Today_in_Julian }
  931.  
  932. function  Date_Within_Range(Min,Max,Test:longint):boolean;
  933. {included for TTT5 compatibility}
  934. begin
  935.    Date_Within_Range := ((Test >= Min) and (Test <= Max));
  936. end; { Date_Within_Range }
  937.  
  938. function  Valid_Date(Indate:string;format:byte): boolean;
  939. {included for TTT5 compatibility}
  940. begin
  941.    Valid_Date := ValidDateStr(Indate,ConvertDateFormat(format));
  942. end; { Valid_Date }
  943.  
  944. function  Future_Date(InDate:string;format:byte;Days:word): string;
  945. {included for TTT5 compatibility}
  946. begin
  947.    Future_Date := RelativeDate(InDate,ConvertDateFormat(format),Days);
  948. end; { Future_Date }
  949.  
  950. function  Unformatted_date(InDate:string): string;
  951. {included for TTT5 compatibility}
  952. begin
  953.    Unformatted_date := UnformattedDate(InDate);
  954. end; { Unformatted_date }
  955.  
  956. {$ENDIF} {TTT5}
  957.  
  958. begin
  959.    GoldDATEInit;
  960. end.
  961.